{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Ochre.Compiler.ElimLet
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Useless Let elimination for K Normal Form.
--
--------------------------------------------------------------------------------

module Ochre.Compiler.ElimLet
  (
    
    elimLet

  ) where


import Ochre.Compiler.CompilerMon
import Ochre.Compiler.Syntax
import Ochre.Compiler.VarId

import Control.Applicative
import qualified Data.Set as S



--------------------------------------------------------------------------------
-- Useless let elimination

anyMembers :: [VarId] -> FreeVars -> Bool
anyMembers vs fvs = any (`S.member` fvs) vs


elimLet :: Expr -> Compiler Expr
elimLet e = elim e


elim :: Expr -> Compiler Expr
elim (LetValue vid val e)           = 
    (\ea -> if S.member vid (freevars ea) 
            then LetValue vid val ea else ea) 
     <$> elim e
                                       
elim (LetSig1 vid e1 e2)            = 
    (\ea eb -> if effect ea || S.member vid (freevars eb)
               then LetSig1 vid ea eb else eb) 
      <$> elim e1 <*> elim e2

elim (LetSig2 v1 v2 e1 e2)          = 
    (\ea eb -> if effect ea || anyMembers [v1,v2] (freevars eb)
               then LetSig2 v1 v2 ea eb else eb) 
      <$> elim e1 <*> elim e2

elim (LetSig3 v1 v2 v3 e1 e2)       = 
    (\ea eb -> if effect ea || anyMembers [v1,v2,v3] (freevars eb)
               then LetSig3 v1 v2 v3 ea eb else eb) 
      <$> elim e1 <*> elim e2

elim (LetSig4 v1 v2 v3 v4 e1 e2)    = 
    (\ea eb -> if effect ea || anyMembers [v1,v2,v3,v4] (freevars eb)
               then LetSig4 v1 v2 v3 v4 ea eb else eb) 
      <$> elim e1 <*> elim e2

elim (Ifte cond e1 e2)              = Ifte cond <$> elim e1 <*> elim e2
elim (e1 :>> e2)                    = (:>>) <$> elim e1 <*> elim e2
elim e                              = return e
